home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Extensions / hash.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-16  |  14.3 KB  |  510 lines
  1. /*
  2.  *
  3.  * h a s h  . c            -- Hash Tables 
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 17-Jan-1994 17:49
  22.  * Last file update: 17-May-1996 17:46
  23.  */
  24.  
  25. #include <stk.h>
  26.  
  27. static void      free_hash_table(SCM ht);
  28. static void      mark_hash_table(SCM ht);
  29. static PRIMITIVE hash_table_hash(SCM obj);
  30.  
  31.  
  32. /**** Definitions for new type tc_hash ****/
  33. static int tc_hash;
  34. static STk_extended_scheme_type hash_table_type = {
  35.   "hash-table",        /* name */
  36.   0,            /* is_procp */
  37.   mark_hash_table,    /* gc_mark_fct */
  38.   free_hash_table,    /* gc_sweep_fct */
  39.   NULL,            /* apply_fct */
  40.   NULL,            /* display_fct */
  41.   NULL,            /* compare_fct */
  42. };
  43.  
  44. typedef enum {hash_eq, hash_string, hash_comp} hash_type;
  45.  
  46. typedef struct {
  47.   struct Tcl_HashTable *h;
  48.   hash_type type;
  49.   SCM comparison;    /* unused if not a comparison hash table */
  50.   SCM sxhash_fct;
  51. } Scheme_hash_table;
  52.  
  53. #define HASH(x)           ((Scheme_hash_table *) ((x)->storage_as.extension.data))
  54. #define LHASH(x)       ((x)->storage_as.extension.data)
  55. #define HASHP(x)       (TYPEP(x, tc_hash))
  56. #define HASH_COMP(x)       (HASH(x)->comparison)
  57. #define HASH_SXHASH(x)       (HASH(x)->sxhash_fct)
  58. #define HASH_H(x)       (HASH(x)->h)
  59. #define HASH_TYPE(x)       (HASH(x)->type)
  60. #define HASH_WORD(h1, h2)  ((((h1) << 4) + (h1)) ^ (h2))  /* Good repartition ? */
  61.  
  62. /* This function is duplicated from tclHash.c
  63.  * It would be possible to export this function form tchHash.c, but I prefer 
  64.  * to avoid modifications, as far as possible, from files in the Tcl directory
  65.  * Given the size of this function, a duplication should not be a problem 
  66.  */
  67. static unsigned long HashString(register char *string)
  68. {
  69.   register unsigned long result;
  70.   register int c;
  71.  
  72.   result = 0;
  73.   for ( ; ; ) {
  74.     c = *string++;
  75.     if (c == 0) break;
  76.     result += (result<<3) + c;
  77.   }
  78.   return result;
  79. }
  80.  
  81. /*
  82.  * sxhash permits to calculate a "universal" hash value  a` la CL sxhash 
  83.  * function
  84.  *
  85.  */
  86. unsigned long sxhash(SCM obj)
  87. {
  88.   register unsigned long h;
  89.   register SCM tmp;
  90.   register int i;
  91.  
  92.   switch (TYPE(obj)) {
  93.     case tc_cons:       h = sxhash(CAR(obj));
  94.                   for(tmp=CDR(obj); CONSP(tmp); tmp=CDR(tmp))
  95.               h = HASH_WORD(h, sxhash(CAR(tmp)));
  96.             h = HASH_WORD(h, sxhash(tmp));
  97.             return h;
  98.     case tc_integer:    
  99.     case tc_bignum:    return (unsigned long) STk_integer_value_no_overflow(obj);
  100.     case tc_flonum:    return (unsigned long) FLONM(obj);
  101.     case tc_symbol:    return HashString(PNAME(obj));
  102.     case tc_keyword:    return HashString(KEYVAL(obj));
  103.     case tc_string:    return HashString(CHARS(obj));
  104.     case tc_vector:    h = 0;
  105.             for (i=VECTSIZE(obj)-1; i >= 0; i--) 
  106.               h = HASH_WORD(h, sxhash(VECT(obj)[i]));
  107.             return h;
  108.     default:            /* Either a small constant or a complex type (STklos
  109.              * object, user defined type, hashtable...). In this 
  110.              * case we return the type of the object. This is very 
  111.              * inneficient but it should be rare to use a structured
  112.              * object as a key. Note that returning the type 
  113.              * works even if we have not COMPACT_SMALL_CST (as far as 
  114.              * I know, nobody undefine it). In this case  SMALL_CSTP
  115.              * always return FALSE.
  116.              */
  117.                    return (SMALL_CSTP(obj)) ? (unsigned long) obj:
  118.                                (unsigned long) TYPE(obj);
  119.   }
  120. }
  121.  
  122. /* 
  123.  * find_key: equivalent to the assoc function except that it works
  124.  * with any comparison. If no association is found, find_key returns
  125.  * NULL 
  126.  */
  127. static SCM find_key(SCM obj, SCM alist, SCM comparison)
  128. {
  129.   register SCM l, tmp;
  130.  
  131.   for(l=alist; !NULLP(l); l=CDR(l)) {
  132.     tmp = CAR(l);
  133.     if (STk_apply(comparison, LIST2(obj, CAR(tmp))) != Ntruth) return tmp;
  134.   }
  135.   return NULL;
  136. }
  137.  
  138. /* 
  139.  * remove_key: remove the given key from the association list.
  140.  * The key is compared with the ``comparison'' function
  141.  */
  142. static SCM remove_key(SCM obj, SCM alist, SCM comparison)
  143. {
  144.   register SCM l, tmp;
  145.  
  146.   for(l=NIL; !NULLP(alist); alist=CDR(alist)) {
  147.     if (STk_apply(comparison, LIST2(obj, CAR(CAR(alist)))) == Ntruth) 
  148.       l = Cons(CAR(alist), l);
  149.   }
  150.   return l;
  151. }
  152.  
  153. /* 
  154.  * The_func returns a cell which represent the ORIGINAL subr given as
  155.  * a string. Don't use intern to avoid problems if "eq?" or
  156.  * "hash-table-hash" have been redefined by the user. This is probably
  157.  * not useful, but ...
  158.  */
  159. static SCM the_func(char *s)
  160. {
  161.   SCM z;
  162.   
  163.   if (strcmp(s, "eq?") == 0) {
  164.     NEWCELL(z, tc_subr_2);
  165.     z->storage_as.subr0.f = (SCM (*)()) STk_eq;
  166.   }
  167.   else { /* s is "hash-table-hash" */
  168.     NEWCELL(z, tc_subr_1);
  169.     z->storage_as.subr0.f = (SCM (*)()) sxhash;
  170.   }
  171.   z->storage_as.subr0.name = s;
  172.   
  173.   return z;
  174. }
  175.  
  176.  
  177.     
  178. /******************************************************************************/
  179.  
  180. /*
  181.  * STk_sxhash: the Scheme version of sxhash
  182.  */
  183. static PRIMITIVE hash_table_hash(SCM obj)
  184. {
  185.   long int x = sxhash(obj);
  186.   
  187.   return STk_makeinteger((x < 0) ? -x : x);
  188. }
  189.  
  190.  
  191. static PRIMITIVE make_hash_table(SCM l, int len)
  192. {
  193.   SCM sxhash, compar, z;
  194.   hash_type type=hash_comp;
  195.  
  196.   switch (len) {
  197.     case 0: compar = the_func("eq?");
  198.             sxhash = the_func("hash-table-hash");
  199.         break;
  200.     case 1: compar = CAR(l);
  201.             sxhash = the_func("hash-table-hash");
  202.         break;
  203.     case 2: compar = CAR(l);
  204.               sxhash = CAR(CDR(l));
  205.         break;
  206.     default: STk_err("make-hash-table: bad list of parameters", l);
  207.   }
  208.  
  209.   if (STk_procedurep(compar) == Ntruth) 
  210.     STk_err("make-hash-table: bad comparison function", compar);
  211.  
  212.   if (STk_procedurep(sxhash) == Ntruth) 
  213.     STk_err("make-hash-table: bad hash function", sxhash);  
  214.  
  215.   if (TYPEP(compar, tc_subr_2))
  216.     /* 
  217.      * We have a procedure. See if it is 'eq?' or 'string?'.
  218.      * If so, we implement the hash table in the most efficient 
  219.      * way. Otherwise, we will use another method (i.e. find a key
  220.      * code for each object with the sxhash  function and strore
  221.      * each element  with this key in a A-list, the A-list for a
  222.      * given key is is found  using the Tcl Hash functions 
  223.      */
  224.     if ((void *) SUBRF(compar) == (void *) STk_eq)    type = hash_eq;    else
  225.     if ((void *) SUBRF(compar) == (void *) STk_streq) type = hash_string;
  226.  
  227.   /* Make a new hash table object */
  228.   NEWCELL(z, tc_hash);
  229.   
  230.   LHASH(z)           = (Scheme_hash_table *)must_malloc(sizeof(Scheme_hash_table));
  231.   HASH(z)->h          = must_malloc(sizeof(Tcl_HashTable));
  232.   HASH(z)->type          = type;
  233.   HASH(z)->sxhash_fct = sxhash;
  234.   HASH(z)->comparison = compar;
  235.   Tcl_InitHashTable(HASH_H(z), (type == hash_string)? TCL_STRING_KEYS :
  236.                                   TCL_ONE_WORD_KEYS);
  237.   return z;
  238. }
  239.  
  240. static PRIMITIVE hash_table_p(SCM obj)
  241. {
  242.   return HASHP(obj) ? Truth: Ntruth;
  243. }
  244.  
  245.  
  246. static PRIMITIVE hash_table_put(SCM ht, SCM key, SCM val)
  247. {
  248.   Tcl_HashEntry *entry;
  249.   SCM index;
  250.   int new;
  251.  
  252.   if (!HASHP(ht)) Err("hash-table-put!: bad hash table", ht);
  253.   
  254.   switch (HASH_TYPE(ht)) {
  255.     case hash_eq: 
  256.       entry = Tcl_CreateHashEntry(HASH_H(ht), (char *) key, &new);
  257.       Tcl_SetHashValue(entry, val);
  258.       break;
  259.     case hash_string:
  260.       if (!STRINGP(key)) Err("hash-table-put!: bad string", key);
  261.       entry = Tcl_CreateHashEntry(HASH_H(ht), CHARS(key), &new);
  262.       Tcl_SetHashValue(entry, val);
  263.       break;
  264.     case hash_comp:
  265.       index = Apply(HASH_SXHASH(ht), LIST1(key));
  266.       entry = Tcl_CreateHashEntry(HASH_H(ht), (char *) index, &new);
  267.       if (new)
  268.     Tcl_SetHashValue(entry, LIST1(Cons(key, val)));
  269.       else {
  270.     SCM old = (SCM) Tcl_GetHashValue(entry);
  271.     SCM tmp = find_key(key, old, HASH_COMP(ht));
  272.  
  273.     if (tmp) {
  274.       CAR(tmp) = key;
  275.       CDR(tmp) = val;
  276.     }
  277.     else
  278.       Tcl_SetHashValue(entry, Cons(Cons(key, val), old));
  279.       }
  280.       break;
  281.   }
  282.   return UNDEFINED;
  283. }
  284.  
  285. static PRIMITIVE hash_table_get(SCM ht, SCM key, SCM default_value)
  286. {
  287.   Tcl_HashEntry *entry;
  288.   SCM index;
  289.  
  290.   if (!HASHP(ht)) Err("hash-table-get: bad hash table", ht);
  291.  
  292.   switch (HASH_TYPE(ht)) {
  293.     case hash_eq: 
  294.       if (entry=Tcl_FindHashEntry(HASH_H(ht), (char *) key))
  295.     /* Key already in hash table */
  296.     return (SCM) Tcl_GetHashValue(entry);
  297.       break;
  298.     case hash_string:
  299.       if (!STRINGP(key)) Err("hash-table-get: bad string", key);
  300.       if (entry=Tcl_FindHashEntry(HASH_H(ht), CHARS(key)))
  301.     /* Key already in hash table */
  302.     return (SCM) Tcl_GetHashValue(entry);
  303.       break;
  304.     case hash_comp:
  305.       index = Apply(HASH_SXHASH(ht), LIST1(key));
  306.       if (entry=Tcl_FindHashEntry(HASH_H(ht), (char *) index)) {
  307.     SCM tmp, val = (SCM) Tcl_GetHashValue(entry);
  308.  
  309.     if (tmp = find_key(key, val, HASH_COMP(ht))) 
  310.       return CDR(tmp);
  311.       }
  312.       break;
  313.   }
  314.   /* If we are here, key was not present in table */
  315.   if (default_value == UNBOUND)  
  316.     Err("hash-table-get: entry not defined for this key", key);
  317.   return default_value;
  318. }
  319.  
  320. static PRIMITIVE hash_table_remove(SCM ht, SCM key)
  321. {
  322.   Tcl_HashEntry *entry;
  323.   SCM index;
  324.  
  325.   if (!HASHP(ht)) Err("hash-table-remove!: bad hash table", ht);
  326.  
  327.   switch (HASH_TYPE(ht)) {
  328.     case hash_eq:
  329.       if (entry=Tcl_FindHashEntry(HASH_H(ht), (char *) key)) 
  330.     /* Key alrady in hash table */
  331.     Tcl_DeleteHashEntry(entry);
  332.       break;
  333.     case hash_string:
  334.       if (!STRINGP(key)) Err("hash-table-remove: bad string", key);
  335.       if (entry=Tcl_FindHashEntry(HASH_H(ht), CHARS(key))) 
  336.     /* Key alrady in hash table */
  337.     Tcl_DeleteHashEntry(entry);
  338.       break;
  339.     case hash_comp:
  340.       index = Apply(HASH_SXHASH(ht), LIST1(key));
  341.       if (entry=Tcl_FindHashEntry(HASH_H(ht), (char *) index)) {
  342.     SCM tmp, val = (SCM) Tcl_GetHashValue(entry);
  343.     
  344.     tmp = remove_key(key, val, HASH_COMP(ht));
  345.  
  346.     if (NULLP(tmp)) 
  347.       /* This was the only entry for this key. We can delete the entry */
  348.       Tcl_DeleteHashEntry(entry);
  349.     else
  350.       Tcl_SetHashValue(entry, tmp);
  351.       }
  352.       break;
  353.   }
  354.   return UNDEFINED;
  355. }
  356.  
  357. static PRIMITIVE hash_table_for_each(SCM ht, SCM proc)
  358. {
  359.   Tcl_HashEntry *entry;
  360.   Tcl_HashSearch search;
  361.  
  362.   if (!HASHP(ht)) Err("hash-table-for-each: bad hash table", ht);
  363.   if (STk_procedurep(proc)==Ntruth) Err("hash-table-for-each: bad procedure", proc);
  364.   
  365.   for (entry = Tcl_FirstHashEntry(HASH_H(ht), &search);
  366.        entry;
  367.        entry = Tcl_NextHashEntry(&search)) {
  368.  
  369.     switch (HASH_TYPE(ht)) {
  370.       case hash_eq:
  371.     Apply(proc, LIST2((SCM) Tcl_GetHashKey(HASH_H(ht), entry),
  372.               (SCM) Tcl_GetHashValue(entry)));
  373.     break;
  374.       case hash_string:
  375.     { 
  376.       char *s = Tcl_GetHashKey(HASH_H(ht), entry);
  377.     
  378.       Apply(proc, LIST2(STk_makestring(s), (SCM) Tcl_GetHashValue(entry)));
  379.     }
  380.     break;
  381.       case hash_comp: 
  382.     {
  383.       SCM val;  
  384.       
  385.       for (val=(SCM) Tcl_GetHashValue(entry); !NULLP(val); val = CDR(val))
  386.         Apply(proc, LIST2(CAR(CAR(val)), CDR(CAR(val))));
  387.     }
  388.     }
  389.   }
  390.   return UNDEFINED;
  391. }
  392.  
  393. static PRIMITIVE hash_table_map(SCM ht, SCM proc)
  394. {
  395.   Tcl_HashEntry *entry;
  396.   Tcl_HashSearch search;
  397.   SCM result = NIL;
  398.  
  399.   if (!HASHP(ht)) Err("hash-table-map: bad hash table", ht);
  400.   if (STk_procedurep(proc)==Ntruth) Err("hash-table-map: bad procedure", proc);
  401.   
  402.   for (entry = Tcl_FirstHashEntry(HASH_H(ht), &search);
  403.        entry;
  404.        entry = Tcl_NextHashEntry(&search)) {
  405.     
  406.     switch (HASH_TYPE(ht)) {
  407.       case hash_eq:
  408.     result = Cons(Apply(proc, LIST2((SCM)Tcl_GetHashKey(HASH_H(ht), entry),
  409.                     (SCM) Tcl_GetHashValue(entry))),
  410.               result);
  411.     break;
  412.       case hash_string:
  413.     { 
  414.       char *s = Tcl_GetHashKey(HASH_H(ht), entry);
  415.     
  416.       result = Cons(Apply(proc, LIST2(STk_makestring(s), 
  417.                       (SCM) Tcl_GetHashValue(entry))),
  418.             result);
  419.     }
  420.     break;
  421.       case hash_comp: 
  422.     {
  423.       SCM val;  
  424.       
  425.       for (val=(SCM) Tcl_GetHashValue(entry); !NULLP(val); val = CDR(val))
  426.         result = Cons(Apply(proc, LIST2(CAR(CAR(val)), CDR(CAR(val)))), 
  427.               result);
  428.     }
  429.     }
  430.   }
  431.   return result;
  432. }
  433.  
  434. static PRIMITIVE hash_table_stats(SCM ht)
  435. {
  436.   Tcl_HashSearch search;
  437.   char *s;
  438.  
  439.   if (!HASHP(ht)) Err("hash-table-stats: bad hash table", ht);
  440.  
  441.   /* 
  442.    * There is a bug in the Tcl/hash module. Tcl_HashStats makes a division by 0 
  443.    * if the hash table is empty.
  444.    */
  445.   if (Tcl_FirstHashEntry(HASH_H(ht), &search)) {
  446.     s = Tcl_HashStats(HASH_H(ht));
  447.     fprintf(STk_stderr, "%s\n", s);
  448.     free(s);
  449.   }
  450.   else 
  451.     fprintf(STk_stderr, "Empty hash table\n");
  452.   return UNDEFINED;
  453. }
  454.  
  455.  
  456. static void free_hash_table(SCM ht)
  457. {
  458.   Tcl_DeleteHashTable(HASH_H(ht));
  459.   free(HASH_H(ht));
  460.   free(HASH(ht));
  461. }
  462.  
  463.  
  464. static void mark_hash_table(SCM ht)
  465. {
  466.   Tcl_HashEntry *entry;
  467.   Tcl_HashSearch search;
  468.  
  469.   /* Mark information stored in the hash structure */
  470.   STk_gc_mark(HASH_COMP(ht));
  471.   STk_gc_mark(HASH_SXHASH(ht));
  472.  
  473.   /* Mark the content of the Tcl hash table */
  474.   for (entry = Tcl_FirstHashEntry(HASH_H(ht), &search);
  475.        entry;
  476.        entry = Tcl_NextHashEntry(&search)) {
  477.  
  478.     /* The only cas where the must be marked is if the hash table is
  479.      * an eq? one. In effect,
  480.      *    hash_eq table: the key is in the Tcl key field and must be marked
  481.      *    hash_string table: Tcl hashtable has made a copy in the entry
  482.      *    hash_comp: the key is in the value field which will be always marked
  483.      */
  484.     if (HASH_TYPE(ht) == hash_eq)
  485.       STk_gc_mark((SCM) Tcl_GetHashKey(HASH_H(ht), entry));
  486.     
  487.     /* and mark the value in all cases */
  488.     STk_gc_mark((SCM) Tcl_GetHashValue(entry));
  489.   }
  490. }
  491.  
  492.  
  493. /******************************************************************************/
  494.  
  495. PRIMITIVE STk_init_hash(void)
  496. {
  497.   tc_hash = STk_add_new_type(&hash_table_type);
  498.  
  499.   STk_add_new_primitive("make-hash-table",     tc_lsubr,       make_hash_table);
  500.   STk_add_new_primitive("hash-table?",           tc_subr_1,      hash_table_p);
  501.   STk_add_new_primitive("hash-table-hash",     tc_subr_1,      hash_table_hash);
  502.   STk_add_new_primitive("hash-table-put!",     tc_subr_3,      hash_table_put);
  503.   STk_add_new_primitive("hash-table-get",      tc_subr_2_or_3, hash_table_get);
  504.   STk_add_new_primitive("hash-table-remove!",  tc_subr_2,      hash_table_remove);
  505.   STk_add_new_primitive("hash-table-for-each", tc_subr_2,      hash_table_for_each);
  506.   STk_add_new_primitive("hash-table-map",      tc_subr_2,      hash_table_map);
  507.   STk_add_new_primitive("hash-table-stats",    tc_subr_1,      hash_table_stats);
  508.   return UNDEFINED;
  509. }
  510.